home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / predef5.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  28KB  |  1,093 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /*    +---------------------------------------------------+
  10.       |                                                   |
  11.       |          I N T E R P     P R E D E F S            |
  12.       |         Part 5: TEXT_IO Scan Procedures           |
  13.       |                  (C Version)                      |
  14.       |                                                   |
  15.       |   Adapted From Low Level SETL version written by  |
  16.       |                                                   |
  17.       |                  Monte Zweben                     |
  18.       |               Philippe Kruchten                   |
  19.       |               Jean-Pierre Rosen                   |
  20.       |                                                   |
  21.       |    Original High Level SETL version written by    |
  22.       |                                                   |
  23.       |                   Clint Goss                      |
  24.       |               Tracey M. Siesser                   |
  25.       |               Bernard D. Banner                   |
  26.       |               Stephen C. Bryant                   |
  27.       |                  Gerry Fisher                     |
  28.       |                                                   |
  29.       |              C version written by                 |
  30.       |                                                   |
  31.       |               Robert B. K. Dewar                  |
  32.       |                                                   |
  33.       +---------------------------------------------------+
  34. */
  35.  
  36. /*  This module contains routines for the implementation of some of
  37.  *  the predefined Ada packages and routines, namely SEQUENTIAL_IO,
  38.  *  DIRECT_IO, TEXT_IO, and CALENDAR. Part 5 contains the scanning
  39.  *  procedures used for TEXT_IO input.
  40. */
  41.  
  42. #include <stdlib.h>
  43. #include <string.h>
  44. #include <ctype.h>
  45. #include "ipredef.h"
  46. #include "machinep.h"
  47. #include "predefp.h"
  48.  
  49. static char getcp();
  50. static char nextc();
  51. static void skipc();
  52. static void copyc();
  53. static void copy_integer();
  54. static void copy_based_integer();
  55. static void scan_blanks();
  56. static void setup_fixed_field(int);
  57. static void test_fixed_field_end();
  58. static int alpha(char);
  59. static int alphanum(char);
  60. static int graphic(char);
  61. static int digit(char);
  62. static int extended_digit(char);
  63. static int sign(char);
  64. static void check_digit();
  65. static void check_hash(char);
  66. static void check_extended_digit();
  67. static void range();
  68. static int scan_int();
  69. static int scan_based_int(int);
  70. static double scan_real_val(int);
  71. static void scan_enum_val();
  72. static int scan_integer_val(int *, int);
  73. static long scan_fixed_val(int *, int);
  74. static float scan_float_val(int *, int);
  75.  
  76. /* The following variables control whether we are scanning from a file or
  77.  * from a string. The flag scan_mode is 'F' if scanning from a file and 'S'
  78.  * if scanning from a string. The pointer ins points to the next character
  79.  * to be scanned in the case where we are scanning from a string.
  80.  */
  81.  
  82. static char scan_mode;
  83. static char *ins;
  84.  
  85. /* The variable s is used to store characters in work_string */
  86.  
  87. static char *s;
  88.  
  89.  
  90. /* GETCP */
  91.  
  92. /* This procedure gets the next character from the string or file being scanned
  93.  * according to the setting of scan_mode. In string mode, ins is updated. If no
  94.  * more character remain to be scanned, then END error is signalled.
  95.  */
  96.  
  97. static char getcp()                                                    /*;getcp*/
  98. {
  99.     if (scan_mode == 'F') {
  100.         return get_char();
  101.     }
  102.     else {
  103.         if (*ins == 0)
  104.             predef_raise(END_ERROR, "End of string encountered");
  105.         return * ins++;
  106.     }
  107. }
  108.  
  109.  
  110. /* NEXTC */
  111.  
  112. /* This procedure returns the next character to be read from the string or file
  113.  * being scanned, according to the setting of scan_mode. In string mode, ins is
  114.  * updated. If we are currently at end of string then a line feed is returned.
  115.  */
  116.  
  117. static char nextc()                                                    /*;nextc*/
  118. {
  119.  
  120.     if (scan_mode == 'F') {
  121.         load_look_ahead(FALSE);
  122.         return CHAR1;
  123.     }
  124.     else {
  125.         if (*ins) return *ins;
  126.         else return LINE_FEED;
  127.     }
  128. }
  129.  
  130.  
  131. /* SKIPC */
  132.  
  133. /* This procedure skips the next input character */
  134.  
  135. static void skipc()                                                  /*;skipc*/
  136. {
  137.     char c;
  138.  
  139.     if (scan_mode == 'F')
  140.         c = get_char();
  141.     else
  142.         ins++;
  143. }
  144.  
  145. /* COPYC */
  146.  
  147. /* This procedure copies the next input character to work_string using s */
  148.  
  149. static void copyc()                                                  /*;copyc*/
  150. {
  151.     char c;
  152.  
  153.     if (scan_mode == 'F')
  154.         c = get_char();
  155.     else
  156.         c = *ins++;
  157.     if (c)
  158.         *s++ = UPPER_CASE(c);
  159.     else
  160.         predef_raise (SYSTEM_ERROR, "End of string encountered");
  161. }
  162.  
  163. /* COPY_INTEGER */
  164.  
  165. /* This procedure copies a string with the syntax of "integer" from the
  166.  * input to the work string. Underscores are allowed but not copied.
  167.  */
  168.  
  169. static void copy_integer()                                      /*;copy_integer*/
  170. {
  171.     check_digit();
  172.  
  173.     while (digit(nextc())) {
  174.         copyc();
  175.         if (nextc() == '_') {
  176.             skipc();
  177.             check_digit();
  178.         }
  179.     }
  180. }
  181.  
  182.  
  183. /* COPY_BASED_INTEGER */
  184.  
  185. /* This procedure copies a string with the syntax of "based_integer" from
  186.  * the input to the work string. Underscores are allowed but not copied.
  187.  */
  188.  
  189. static void copy_based_integer()                      /*;copy_based_integer*/
  190. {
  191.     check_extended_digit();
  192.  
  193.     while (extended_digit(nextc())) {
  194.         copyc();
  195.         if (nextc() == '_') {
  196.             skipc();
  197.             check_extended_digit();
  198.         }
  199.     }
  200. }
  201.  
  202. /* SCAN_BLANKS */
  203.  
  204. /* Routine to scan past leading blanks to find first non-blank. Signals
  205.  * an exception if no non-blank character is located.
  206. */
  207.  
  208. static void scan_blanks()                                     /*;scan_blanks*/
  209. {
  210.     char c;
  211.  
  212.     if (scan_mode == 'F') {
  213.         for (;;) {
  214.             load_look_ahead(FALSE);
  215.             if (CHARS == 0)
  216.                 predef_raise(END_ERROR, "No item found");
  217.             c = nextc();
  218.             if (c == ' ' || c == HT || c == PAGE_MARK || c == LINE_FEED)
  219.                 getcp();
  220.             else break;
  221.         }
  222.         return;
  223.     }
  224.     else {
  225.         while(*ins == ' ' || *ins == HT) ins++;
  226.         return;
  227.     }
  228. }
  229.  
  230.  
  231. /* SETUP_FIXED_FIELD */
  232.  
  233. /* This procedure is used for numeric conversions where the field to be scanned
  234.  * has a fixed width(i.e. width parameter is non-zero). It acquires the field
  235.  * from the input file and copies it to work_string. It returns to the caller
  236.  * ready to scan the data from work_string.
  237.  */
  238.  
  239. static void setup_fixed_field(int width)                /*;setup_fixed_field*/
  240. {
  241.     char   *p;
  242.  
  243.     p = work_string;
  244.     for (;;) {
  245.         load_look_ahead(FALSE);
  246.         if (width-- != 0 && CHARS != 0 && CHAR1 != PAGE_MARK
  247.                                        && CHAR1 != LINE_FEED) {
  248.             *p++ = get_char();
  249.         }
  250.         else break;
  251.     }
  252.     *p = '\0';
  253.     scan_mode = 'S';
  254.     ins = work_string;
  255. }
  256.  
  257.  
  258. /* TEST_FIXED_FIELD_END */
  259.  
  260. /* This procedure is called after scanning an item from a fixed length field
  261.  * to ensure that only blanks remain in the field. An exception is raised if
  262.  * there are any unexpected non-blank characters left in the field.
  263. */
  264.  
  265. static void test_fixed_field_end()                    /*;test_fixed_field_end*/
  266. {
  267.     scan_blanks();
  268.     if (*ins)
  269.         predef_raise(data_exception,"Unexpected non-blank characters in field");
  270. }
  271.  
  272. /* ALPHA */
  273.  
  274. /* Procedure to test if character argument is an upper or lower case letter,
  275.  * returns TRUE if the argument is a letter, FALSE if it is not.
  276. */
  277.  
  278. static int alpha(char c)                                            /*;alpha*/
  279. {
  280.     if (c > 'Z')
  281.         c -= 32;
  282.     return ('A' <= c && c <= 'Z');
  283. }
  284.  
  285.  
  286. /* ALPHANUM */
  287.  
  288. /* Procedure to test if character argument is an upper or lower case letter,
  289.  * or a digit. Returns TRUE if the argument is a letter or digit, else FALSE.
  290. */
  291.  
  292. static int alphanum(char c)                             /*;alphanum*/
  293. {
  294.     if (c > 'Z')
  295.         c -= 32;
  296.     return (('A' <= c && c <= 'Z') ||('0' <= c && c <= '9'));
  297. }
  298.  
  299.  
  300. /* GRAPHIC */
  301.  
  302. /*  Procedure to test if character is an ASCII graphic character. Returns
  303.  *  Returns TRUE if the argument is an ASCII graphic, else FALSE.
  304. */
  305.  
  306. static int graphic(char c)                                          /*;graphic*/
  307. {
  308.     return (0x20 <= c && c <= 0x7f);
  309. }
  310.  
  311.  
  312. /* DIGIT */
  313.  
  314. /* Procedure to test if character is a digit, returns TRUE or FALSE */
  315.  
  316. static int digit(char c)                                /*;digit*/
  317. {
  318.     return ('0' <= c && c <= '9');
  319. }
  320.  
  321.  
  322. /* EXTENDED_DIGIT */
  323.  
  324. /* Procedure to test if character is extended digit, returns TRUE or FALSE */
  325.  
  326. static int extended_digit(char c)                       /*;extended_digit*/
  327. {
  328.     return ('0' <= c && c <= '9') || ('a' <= c && c <= 'f') ||
  329.       ('A' <= c && c <= 'F');
  330. }
  331.  
  332.  
  333. /* SIGN */
  334.  
  335. /* Procedure to test if character is a sign, returns TRUE or FALSE */
  336.  
  337. static int sign(char c)                                                 /*;sign*/
  338. {
  339.     return (c == '-' || c == '+');
  340. }
  341.  
  342.  
  343. /* CHECK_DIGIT */
  344.  
  345. /* Procedure to determine if next character is a digit, exception if not */
  346.  
  347. static void check_digit()                                      /*;check_digit*/
  348. {
  349.     char c = nextc();
  350.     if (c < '0' || c > '9')
  351.         predef_raise(data_exception, "Invalid digit");
  352. }
  353.  
  354. /* CHECK_HASH */
  355.  
  356. /* Procedure to determine if next character is a matching hash,
  357.  * exception if not. Stores '#' in work string.
  358.  */
  359.  
  360. static void check_hash(char c)                                   /*;check_hash*/
  361. {
  362.     if (nextc() != c)
  363.         predef_raise(data_exception, "Missing # in based number");
  364.     skipc();
  365.     *s++ = '#';
  366. }
  367.  
  368. /* CHECK_EXTENDED_DIGIT */
  369.  
  370. /* Procedure to determine if next char is extended digit, exception if not */
  371.  
  372. static void check_extended_digit()                  /*;check_extended_digit*/
  373. {
  374.     if (!extended_digit(nextc()))
  375.         predef_raise(data_exception, "Invalid extended digit");
  376. }
  377.  
  378. /* RANGE */
  379.  
  380. /* Procedure called if scanned number is out of range */
  381.  
  382. static void range()                                                   /*;range*/
  383. {
  384.     predef_raise(data_exception, "Number out of range");
  385. }
  386.  
  387.  
  388. /* SCAN_INT */
  389.  
  390. /* This routine scans an integer value from the string pointed to by the
  391.  * global pointer s. On exit s is updated to point to the first non-digit.
  392.  * The result returned is always negative. This allows the largest negative
  393.  * integer value to be properly stored and converted. A value of +1 returned
  394.  * indicates that overflow occured.
  395. */
  396.  
  397. static int scan_int()                                          /*;scan_int*/
  398. {
  399.     int     ival;
  400.     int     digit_value;
  401.     int     overflow1, overflow2;
  402.  
  403.     ival = 0;
  404.     while (digit(*s)) {
  405.         ival = word_mul(ival,10,&overflow1);
  406.         digit_value = *s++ - '0';
  407.         ival = word_sub(ival,digit_value,&overflow2);
  408.         if (overflow1 || overflow2) {
  409.             while (digit(*s)) s++;
  410.             return 1;
  411.         }
  412.     }
  413.     return ival;
  414. }
  415.  
  416.  
  417. /* SCAN_BASED_INT */
  418.  
  419. /* This routine scans a based integer value from the string pointed to by the
  420.  * global pointer s. On exit s is updated to point to the first non-digit.
  421.  * The result returned is always negative. This allows the largest negative
  422.  * integer value to be properly stored and converted. If overflow is detected,
  423.  * then the value +1 is returned to signal overflow.
  424. */
  425.  
  426. static int scan_based_int(int base)                           /*;scan_based_int*/
  427. {
  428.     int     ival;
  429.     int     digit_value;
  430.     int     overflow1, overflow2;
  431.  
  432.     ival = 0;
  433.     while (extended_digit(*s)) {
  434.         ival = word_mul(ival,base,&overflow1);
  435.         digit_value = *s++ - '0';
  436.         if (digit_value > 9) digit_value -= 7;
  437.         if (digit_value >= base) {
  438.             predef_raise (data_exception,"Digit out of range of base");
  439.         }
  440.         ival = word_sub(ival,digit_value,&overflow2);
  441.         if (overflow1 || overflow2) {
  442.             while (extended_digit(*s)) s++;
  443.             return 1;
  444.         }
  445.     }
  446.     return ival;
  447. }
  448.  
  449.  
  450. /* SCAN_REAL_VAL */
  451.  
  452. /* Procedure to scan a real value and return the result as a double real.
  453.  * A range exception is signalled if the value is out of range of allowed
  454.  * Ada real values, but no other range check is made.
  455.  */
  456.  
  457. static double scan_real_val(int fixed_field)                 /*;scan_real_val*/
  458. {
  459.     double  dval;            /* value being scanned */
  460.     char    sign_val;        /* sign of mantissa */
  461.     char    exp_sign_val;    /* sign of exponent */
  462.     char    c;               /* character scanned */
  463.     int     base;            /* base as integer */
  464.     double  dbase;           /* base as real */
  465.     double  fraction;        /* power of ten fraction after decimal point */
  466.     int     dig;             /* next digit value */
  467.     double  ddig;            /* next digit as real */
  468.     int     based;           /* TRUE if number is based */
  469.     long    exponent;        /* value of exponent */
  470.     int     before_point;    /* TRUE if before decimal point */
  471.  
  472.     /* First scan out item with the proper syntax and put it in work_string */
  473.  
  474.     s = work_string;
  475.  
  476.     if (sign(nextc())) copyc();
  477.  
  478.     copy_integer();
  479.  
  480.     c = nextc();
  481.     if (c == '#' || c == ':') {
  482.         skipc();
  483.         *s++ = '#';
  484.         copy_based_integer();
  485.         if (nextc() != '.')
  486.             predef_raise(DATA_ERROR,"Missing period in real value");
  487.         copyc();
  488.         copy_based_integer();
  489.         check_hash(c);
  490.         based = TRUE;
  491.     }
  492.     else {
  493.         based = FALSE;
  494.         if (nextc() != '.')
  495.             predef_raise(DATA_ERROR,"Missing period in real value");
  496.         copyc();
  497.         copy_integer();
  498.     }
  499.  
  500.     c = nextc();
  501.     if (c == 'e' || c == 'E') {
  502.         copyc();
  503.         c = nextc();
  504.         if (sign(nextc())) copyc();
  505.         copy_integer();
  506.     }
  507.      
  508.     if (fixed_field)
  509.         test_fixed_field_end();        
  510.  
  511.     *s = 0;
  512.  
  513.     /* Now we have the real literal stored in work_string, so prepare to
  514.      * convert the value, dealing first with setting the proper sign. Note
  515.      * that we can assume that the syntax of the literal is correct since
  516.      * we did all the checking above as we scanned it out.
  517.     */
  518.  
  519.     s = work_string;
  520.     if (sign(*s)) sign_val = *s++; else sign_val = '+';
  521.  
  522.     /* Acquire the proper base value. Note that scan_int returns the negative
  523.      * of the value scanned, with +1 indicating overflow which will be invalid.
  524.     */
  525.  
  526.     if (based) {
  527.         base = scan_int();
  528.         if (base < -16 || base > -2)
  529.             predef_raise(DATA_ERROR, "Invalid base");
  530.         base = -base;
  531.         s++;
  532.     }
  533.     else base = 10;
  534.     dbase = (double)base;
  535.  
  536.     /* Scan and convert digits */
  537.  
  538.     dval = 0.0;
  539.     before_point = TRUE;
  540.     for (;;) {
  541.         if (*s == 0) break;
  542.         if (*s == '#') {
  543.             s++;
  544.             break;
  545.         }
  546.         if (!based && *s == 'E') break;
  547.         c = *s++;
  548.         if (c == '.') {
  549.             before_point = FALSE;
  550.             fraction = 1.0;
  551.         }
  552.         else {
  553.             dig = c - '0';
  554.             if (dig > 9) dig -= 7;     /* convert hex digit */
  555.             if (dig > base) predef_raise (DATA_ERROR, "Digit > base");
  556.             ddig = (double)dig;
  557.             if (before_point) {
  558.                 dval = dval * dbase + ddig;
  559.                 if (dval > ADA_MAX_REAL) range();
  560.             }
  561.             else {
  562.                 fraction /= base;
  563.                 dval = dval + ddig * fraction;
  564.             }
  565.         }
  566.     }
  567.  
  568.     /* Deal with exponent if present */
  569.  
  570.     if (*s == 'E') {
  571.         s++;
  572.  
  573.         if (sign(*s)) exp_sign_val = *s++; else exp_sign_val = '+';
  574.         exponent = scan_int();
  575.  
  576.         /* A value of +1 in exponent means that scan_int detected overflow.
  577.          * This is not yet a range error. If the mantissa is 0 or 1, the
  578.          * effect is as if we had an exponent of 1.
  579.         */
  580.  
  581.         if (exponent == 1) {
  582.             if (dval == 0.0 || dval == 1.0) {
  583.                 exponent = 1;
  584.             }
  585.  
  586.         /* If we have a positive exponent, then if the mantissa is greater than
  587.          * 1.0, we do have an overflow, otherwise if the mantissa is less than
  588.          * 1.0, we have an underflow situation giving a result of zero.
  589.         */
  590.  
  591.             else if (exp_sign_val == '+') {
  592.                 if (dval > 1.0) range();
  593.                 else dval = 0.0;
  594.             }
  595.  
  596.         /* For a negative exponent, the situation is the other way round, since
  597.          * we want in effect the reciprocal of the value for the positive case.
  598.         */
  599.  
  600.             else {
  601.                 if (dval > 1.0) dval = 0.0;
  602.                 else range();
  603.             }
  604.         }
  605.  
  606.         /* If no overflow, get abs value of exponent (scan_int returned -exp) */
  607.  
  608.         else exponent = -exponent;
  609.  
  610.         /* An optimization: if the mantissa is zero , save a lot of time
  611.          * in converting silly numbers like 0E+25000 by resetting exponent.
  612.         */
  613.  
  614.         if (dval == 0.0) {
  615.             exponent = 0;
  616.         }
  617.  
  618.         /* Adjust mantissa by exponent, using proper exponent sign */
  619.  
  620.         if (exp_sign_val == '+') {
  621.             while (exponent > 0) {
  622.                 dval *= dbase;
  623.                 if (dval > ADA_MAX_REAL) range();
  624.                 exponent--;
  625.             }
  626.         }
  627.         else {
  628.             while (exponent > 0) {
  629.                 dval /= dbase;
  630.                 exponent--;
  631.             }
  632.         }
  633.     }
  634.  
  635.     /* Return scanned value with proper sign */
  636.  
  637.     if (sign_val == '+') return dval;
  638.     else return -dval;
  639. }
  640.  
  641.  
  642. /* SCAN_ENUM_VAL */
  643.  
  644. /* Procedure to scan an Ada enumeration literal, which may be an identifier
  645.  * identifier or a character literal. The result is stored in work_string.
  646. */
  647.  
  648. static void scan_enum_val()                               /*;scan_enum_val*/
  649. {
  650.     scan_blanks();
  651.     if (scan_mode == 'S' && *ins == 0) {
  652.         predef_raise(END_ERROR, "String is all blanks");
  653.     }
  654.     s = work_string;
  655.  
  656.  /* Try identifier */
  657.  
  658.     if (alpha(nextc())) {
  659.         while(alphanum(nextc())) {
  660.             copyc();
  661.             if (nextc() == '_')
  662.                 copyc();
  663.         }
  664.         *s = '\0';
  665.         return;
  666.     }
  667.  
  668.  /* Try character literal: */
  669.  
  670.     if (nextc() == QUOTE) {
  671.         copyc();
  672.         if (graphic(nextc())) {
  673.             *s++ = getcp();     /* can't use copyc, do not want fold */
  674.             if (nextc() == QUOTE) {
  675.                 copyc();
  676.                 *s = 0;
  677.                 return;
  678.             }
  679.         }
  680.         predef_raise(data_exception, "Illegal character literal");
  681.     }
  682.     predef_raise(data_exception, "Illegal enumeration literal");
  683. }
  684.  
  685.  
  686. /* SCAN_ENUM */
  687.  
  688. /* Procedure to scan an Ada enumeration literal, which may be an identifier
  689.  * identifier or a character literal. The result is stored in work_string.
  690.  * For this case, the input is from the current TEXT_IO input file.
  691. */
  692.  
  693. void scan_enum()                                             /*scan_enum*/
  694. {
  695.     scan_mode = 'F';
  696.     scan_enum_val();
  697. }
  698.  
  699.  
  700. /* SCAN_ENUM_STRING */
  701.  
  702. /* Procedure to scan an Ada enumeration literal, which may be an identifier
  703.  * identifier or a character literal. The result is stored in work_string.
  704.  * For this case, the input is from the string stored in work_string. On
  705.  * return, last is the count of characters scanned minus one.
  706. */
  707.  
  708. void scan_enum_string(int *last)                  /*;scan_enum_string*/
  709. {
  710.     scan_mode = 'S';
  711.     ins = work_string;
  712.     scan_enum_val();
  713.     *last = ins - work_string - 1;
  714. }
  715.  
  716.  
  717. /* SCAN_INTEGER_VAL */
  718.  
  719. /* Procedure to scan an Ada integer value and return the integer result. The
  720.  * parameter num_type is a pointer to the type template for the integer.
  721.  */
  722.  
  723. static int scan_integer_val(int *num_type, int fixed_field)/*;scan_integer_val*/
  724. {
  725.     int    ival;             /* value of integer signed */
  726.     char   sign_val;         /* sign of value '+' or '-' */
  727.     char   c;                /* character scanned from string */
  728.     int    base;             /* base value 2-16 */
  729.     int    based;            /* TRUE if number is based */
  730.     int    exponent;         /* exponent value */
  731.     int    overflow;         /* flag used to detect overflow */
  732.  
  733.     /* First scan out item with the proper syntax and put it in work_string */
  734.  
  735.     s = work_string;
  736.  
  737.     if (sign(nextc())) copyc();
  738.  
  739.     copy_integer();
  740.  
  741.     c = nextc();
  742.     if (c == '#' || c == ':') {
  743.         skipc();
  744.         *s++ = '#';
  745.         copy_based_integer();
  746.         check_hash(c);
  747.         based = TRUE;
  748.     }
  749.     else based = FALSE;
  750.  
  751.     c = nextc();
  752.     if (c == 'e' || c == 'E') {
  753.         copyc();
  754.         c = nextc();
  755.         if (c == '+' || c == '-') skipc();
  756.         copy_integer();
  757.         if (c == '-')
  758.             predef_raise(data_exception,"Negative exponent in integer value");
  759.     }
  760.  
  761.     if (fixed_field)
  762.         test_fixed_field_end();
  763.  
  764.     *s = 0;
  765.  
  766.     /* Now we have the integer literal stored in work_string */
  767.  
  768.     s = work_string;
  769.     if (sign(*s)) sign_val = *s++; else sign_val = '+';
  770.  
  771.     if (based) {
  772.         base = -scan_int();
  773.         if (base < 2 || base > 16)
  774.             predef_raise(data_exception, "Invalid base");
  775.         s++;
  776.         ival = scan_based_int(base);
  777.         s++;
  778.     }
  779.     else {
  780.         ival = scan_int();
  781.         base = 10;
  782.     }
  783.  
  784.     /* Number is in ival (in negative form), deal with exponent */
  785.  
  786.     if (ival == 1) range();
  787.     if (*s++ == 'E') {
  788.         exponent = scan_int();
  789.         if (exponent < -64 || exponent == 1) range();
  790.         while (exponent++) {
  791.             ival = word_mul(ival,base,&overflow);
  792.             if (overflow) range();
  793.         }
  794.     }
  795.  
  796.     if (sign_val == '+') {
  797.         ival = -ival;
  798.         if (ival < 0) range();         /* twos complement wrap test */
  799.     }
  800.  
  801.     /* Check number is in range of type */
  802.  
  803.     if (ival < I_RANGE(num_type)->ilow || ival > I_RANGE(num_type)->ihigh)
  804.         range();
  805.  
  806.     return ival;
  807. }
  808.  
  809.  
  810. /* SCAN_INTEGER */
  811.  
  812. /* Procedure to scan an Ada integer value and return the integer result
  813.  * The parameter num_type is a pointer to the type template for the integer.
  814.  * and width specifies the width of the field(zero = unlimited scan).
  815.  * For this case, the input is from the current TEXT_IO input file.
  816. */
  817.  
  818. int scan_integer(int *num_type, int width)                     /*;scan_integer*/
  819. {
  820.     int     result;
  821.  
  822.     if (width != 0) {
  823.         setup_fixed_field(width);
  824.         scan_blanks();
  825.         if (*ins == 0)
  826.             predef_raise(DATA_ERROR, "String is all blanks");
  827.         result = scan_integer_val(num_type,TRUE);
  828.     }
  829.     else {
  830.         scan_mode = 'F';
  831.         scan_blanks();
  832.         result = scan_integer_val(num_type,FALSE);
  833.     }
  834.     return result;
  835. }
  836.  
  837.  
  838. /* SCAN_INTEGER_STRING */
  839.  
  840. /* Procedure to scan an Ada integer value and return the integer result
  841.  * For this case, the input is from the string stored in work_string. On
  842.  * return, last is the count of characters scanned minus one.
  843. */
  844.  
  845. int scan_integer_string(int *num_type, int *last)     /*;scan_integer_string*/
  846. {
  847.     int     result;
  848.  
  849.     scan_mode = 'S';
  850.     ins = work_string;
  851.     scan_blanks();
  852.     if (*ins == 0) {
  853.         predef_raise(END_ERROR, "String is all blanks");
  854.     }
  855.     result = scan_integer_val(num_type,FALSE);
  856.     *last = ins - work_string - 1;
  857.     return result;
  858. }
  859.  
  860.  
  861. /* SCAN_FIXED_VAL */
  862.  
  863. /* Procedure to scan an Ada fixed value and return the fixed result. The
  864.  * parameter num_type is a pointer to the type template for the fixed type.
  865. */
  866.  
  867. static long scan_fixed_val(int *num_type, int fixed_field)   /*;scan_fixed_val*/
  868. {
  869.     double dval = scan_real_val(fixed_field);
  870.     int exp2, exp5;
  871.  
  872.     /* Convert real to equivalent fixed value, using powers of 2 and 5 */
  873.  
  874.     exp2 = FX_RANGE(num_type)->small_exp_2;
  875.     exp5 = FX_RANGE(num_type)->small_exp_5;
  876.  
  877.     while (exp2 > 0) {exp2--; dval /= 2.0;}
  878.     while (exp2 < 0) {exp2++; dval *= 2.0;}
  879.     while (exp5 > 0) {exp5--; dval /= 5.0;}
  880.     while (exp5 < 0) {exp5++; dval *= 5.0;}
  881.  
  882.     /* We now have the proposed fixed value, still stored in real form, in
  883.      * dval. Round to nearest integer, ready for conversion to fixed form.
  884.     */
  885.  
  886.     if (dval >= 0.0) dval += 0.5;
  887.     else dval -= 0.5;
  888.  
  889.     /* Check that value is in range */
  890.  
  891.     if ( (long)dval > (FX_RANGE(num_type)->fxhigh)
  892.       || (long)dval < (FX_RANGE(num_type)->fxlow))
  893.         range();
  894.  
  895.     return (long)dval;
  896. }
  897.  
  898. /* SCAN_FIXED */
  899.  
  900. /* Procedure to scan an Ada fixed value and return the fixed result. The
  901.  * parameter num_type is a pointer to the type template for the fixed type.
  902.  * and width specifies the width of the field(zero = unlimited scan).
  903.  * For this case, the input is from the current TEXT_IO input file.
  904. */
  905.  
  906. long scan_fixed(int *num_type, int width)     /*;scan_fixed*/
  907. {
  908.     long    result;
  909.  
  910.     if (width != 0) {
  911.         setup_fixed_field(width);
  912.         scan_blanks();
  913.         if (*ins == 0)
  914.             predef_raise(DATA_ERROR, "String is all blanks");
  915.         result = scan_fixed_val(num_type,TRUE);
  916.     }
  917.     else {
  918.         scan_mode = 'F';
  919.         scan_blanks();
  920.         result = scan_fixed_val(num_type,FALSE);
  921.     }
  922.  
  923.     return result;
  924. }
  925.  
  926. /* SCAN_FIXED_STRING */
  927.  
  928. /* Procedure to scan an Ada fixed value and return the integer result. The
  929.  * parameter num_type is a pointer to the type template for the integer.
  930.  * and width specifies the width of the field(zero = unlimited scan).
  931.  * For this case, the input is from the string stored in work_string. On
  932.  * return, last is the count of characters scanned minus one.
  933. */
  934.  
  935. long scan_fixed_string(int *num_type, int *last)       /*;scan_fixed_string*/
  936. {
  937.     long    result;
  938.  
  939.     scan_mode = 'S';
  940.     ins = work_string;
  941.     scan_blanks();
  942.     if (*ins == 0)
  943.         predef_raise(END_ERROR, "String is all blanks");
  944.     result = scan_fixed_val(num_type,FALSE);
  945.     *last = ins - work_string - 1;
  946.     return result;
  947. }
  948.  
  949.  
  950. /* SCAN_FLOAT_VAL */
  951.  
  952. /* Procedure to scan an Ada float value and return the float result. The
  953.  * parameter num_type is a pointer to the type template for the float type.
  954. */
  955.  
  956. static float scan_float_val(int *num_type, int fixed_field)  /*;scan_float_val*/
  957. {
  958.     double    dval;
  959.  
  960.     dval = scan_real_val(fixed_field);
  961.  
  962.     /* Check that value is in range */
  963.  
  964.     if ( dval > (double)(FL_RANGE(num_type)->flhigh)
  965.       || dval < (double)(FL_RANGE(num_type)->fllow))
  966.         range();
  967.     return (float)dval;
  968. }
  969.  
  970. /* SCAN_FLOAT */
  971.  
  972. /* Procedure to scan an Ada float value and return the float result. The
  973.  * parameter num_type is a pointer to the type template for the float type.
  974.  * and width specifies the width of the field(zero = unlimited scan).
  975.  * For this case, the input is from the current TEXT_IO input file.
  976. */
  977.  
  978. float scan_float(int *num_type, int width)                         /*;scan_float*/
  979. {
  980.     float   result;
  981.  
  982.     if (width != 0) {
  983.         setup_fixed_field(width);
  984.         scan_blanks();
  985.         if (*ins == 0)
  986.             predef_raise(DATA_ERROR, "String is all blanks");
  987.         result = scan_float_val(num_type,TRUE);
  988.     }
  989.     else {
  990.         scan_mode = 'F';
  991.         scan_blanks();
  992.         result = scan_float_val(num_type,FALSE);
  993.     }
  994.  
  995.     return result;
  996. }
  997.  
  998. /* SCAN_FLOAT_STRING */
  999.  
  1000. /* Procedure to scan an Ada float value and return the integer result. The
  1001.  * parameter num_type is a pointer to the type template for the integer.
  1002.  * and width specifies the width of the field(zero = unlimited scan).
  1003.  * For this case, the input is from the string stored in work_string. On
  1004.  * return, last is the count of characters scanned minus one.
  1005. */
  1006.  
  1007. float scan_float_string(int *num_type, int *last)       /*;scan_float_string*/
  1008. {
  1009.     float   result;
  1010.  
  1011.     scan_mode = 'S';
  1012.     ins = work_string;
  1013.     scan_blanks();
  1014.     if (*ins == 0)
  1015.         predef_raise(END_ERROR, "String is all blanks");
  1016.     result = scan_float_val(num_type,FALSE);
  1017.     *last = ins - work_string - 1;
  1018.     return result;
  1019. }
  1020.  
  1021. /* ENUM_ORD */
  1022.  
  1023. /* Returns the ORD value corresponding to the literal stored in the global
  1024.  * variable work_string. The parameter type_ptr points to the template for
  1025.  * the enumeration subtype. An exception is signalled if there is no matching
  1026.  * value, using the exception code given as an argument.
  1027. */
  1028.  
  1029. int enum_ord(int *type_ptr, int slen, int exception_to_raise)      /*;enum_ord*/
  1030. {
  1031.     int     lbd, ubd, type_ubd;
  1032.     int     *lit_ptr;
  1033.     int     lit_len, str_len;
  1034.     int     i;
  1035.     int     *lp;
  1036.     char    *sp;
  1037.     int     item_val;
  1038.  
  1039.     /* slen is non-negative if string length known */
  1040.     if (slen == -1)        /* if length uncertain, compute it */
  1041.         str_len = strlen(work_string);
  1042.     else            /* if length known, use it */
  1043.         str_len = slen;    /* This is true for character literal case */
  1044.  
  1045.     lbd = E_RANGE(type_ptr) -> elow;
  1046.     ubd = E_RANGE(type_ptr) -> ehigh;
  1047.     if (TYPE(type_ptr) == TT_E_RANGE)     /* an actual subtype */
  1048.         type_ptr = ADDR(E_RANGE(type_ptr) -> ebase, E_RANGE(type_ptr) -> eoff);
  1049.  
  1050.     type_ubd = E_RANGE(type_ptr) -> ehigh;
  1051.     lit_ptr = type_ptr + WORDS_E_RANGE;
  1052.     item_val = 0;
  1053.  
  1054.     if (*lit_ptr == -1) { /* special case for type CHARACTER */
  1055.         if (str_len == 3 && work_string[0] == '\'' && work_string[2] == '\'')
  1056.             item_val = work_string[1];
  1057.         else
  1058.             predef_raise(exception_to_raise, "Illegal character literal");
  1059.     }
  1060.     else { /* normal case */
  1061.         while(item_val <= type_ubd) {
  1062.             lit_len = *lit_ptr++;
  1063.             if (lit_len == str_len) {
  1064.                 i = lit_len;
  1065.                 lp = lit_ptr;
  1066.                 sp = work_string;
  1067.                 /* Do not fold character literals to upper case */
  1068.                 if (work_string[0] != '\'') {
  1069.                     while(i--) {
  1070.                         char c = (islower(*sp) ? toupper(*sp) : *sp);
  1071.                         *sp++ = c;
  1072.                     }
  1073.                 }
  1074.                 sp = work_string;
  1075.                  i = lit_len;
  1076.                 while(i &&(*lp++ == *sp++))
  1077.                     i--;
  1078.                 if (i == 0)
  1079.                     break;
  1080.             }
  1081.             lit_ptr += lit_len;
  1082.             item_val++;
  1083.         }
  1084.     }
  1085.  
  1086.     /* If the literal is not found, item_val is surely out of bounds... */
  1087.  
  1088.     if (item_val < lbd || item_val > ubd)
  1089.         predef_raise(exception_to_raise, "Illegal enumeration literal");
  1090.  
  1091.     return item_val;
  1092. }
  1093.